home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / interpret.c < prev    next >
C/C++ Source or Header  |  1993-07-15  |  12KB  |  481 lines
  1. /*
  2.  * Bytecode Interpreter for Feel
  3.  */
  4. char *interpret_c="$id$";
  5.  
  6. #ifdef BCI
  7. #include <stdio.h>
  8.  
  9. #include "defs.h"
  10. #include "structs.h"
  11. #include "funcalls.h"
  12. #include "global.h"
  13. #include "ngenerics.h"
  14. #include "modules.h"
  15. #include "bvf.h"
  16. #include "allocate.h"
  17. #include "modboot.h"
  18. #include "bootstrap.h"
  19. #include "error.h"
  20. #include "reader.h"
  21. /* Definition of the bytecodes */  
  22. #define COUNT_BYTES /* ---- I want to see what goes on... */
  23. #include "iset.h"
  24. #include "interpret.h"
  25. #include "bytecodes.h"
  26. #include "reader.h"
  27. #include "threads.h"
  28.  
  29. /* classes */
  30. static LispObject ByteFunction_Class;
  31. static LispObject ByteFunction,ExtByteFunction;
  32.  
  33. /* Boot Modules */
  34. #define MAX_BOOT_MODULES 50
  35.  
  36. BC_GLOBALS()
  37.  
  38. /* Function that returns to 'c' */
  39. static LispObject Cb_generic_lookup;
  40.  
  41. /* Interface from the world */
  42. LispObject compute_and_apply_method();
  43. LispObject call_method();
  44. LispObject module_apply_args();
  45.  
  46. /* The biggie */
  47. LispObject interpret_bytes(LispObject *stacktop, bytecode *start_pc, LispObject context)
  48. {
  49.   /* locals for a few specials */
  50.   LispObject BCtrue=lisptrue;
  51.   LispObject BCnil=nil;
  52.   LispObject BC_globals;
  53.   bytecode *pc;
  54.   LispObject *sp;
  55.   LispObject this_context;
  56.  
  57.   BC_INITIALISE_GLOBALS();
  58.  
  59.   while (TRUE)
  60.     {
  61.       BC_PRESWITCH();
  62.       switch(*(pc++))
  63.     {
  64.       
  65.       BC_CASE(BC_NOP);
  66.       
  67.       /* Globals, etc */
  68.       BC_CASE(BC_PUSH_GLOBAL);
  69.       BC_CASE(BC_SET_GLOBAL);
  70.       BC_CASE(BC_PUSH_SPECIAL);
  71.       BC_CASE(BC_PUSH_STATIC);
  72.       BC_CASE(BC_PUSH_FIXNUM);
  73.       BC_CASE(BC_PUSH_SMALL_FIXNUM);
  74.       BC_CASE(BC_SET_STATIC);
  75.  
  76.       /* stack refs */
  77.       BC_CASE(BC_PUSH_NTH);
  78.       BC_CASE(BC_PUSH_NTH_0);
  79.       BC_CASE(BC_PUSH_NTH_1);
  80.       BC_CASE(BC_PUSH_NTH_2);
  81.       BC_CASE(BC_PUSH_NTH_3);
  82.       BC_CASE(BC_SET_NTH);
  83.       
  84.       
  85.       /* env reference */
  86.       BC_CASE(BC_ENV_REF);
  87.       BC_CASE(BC_SET_ENV);
  88.       BC_CASE(BC_POP_ENV);
  89.       BC_CASE(BC_MAKE_ENV);
  90.  
  91.       /* object reference */
  92.       BC_CASE(BC_VREF);
  93.       BC_CASE(BC_SET_VREF);
  94.       BC_CASE(BC_SLOT_REF);
  95.       BC_CASE(BC_SLOT_REF_0);
  96.       BC_CASE(BC_SLOT_REF_1);
  97.       BC_CASE(BC_SET_SLOT);
  98.       BC_CASE(BC_SET_SLOT_1);
  99.       BC_CASE(BC_SET_TYPE);
  100.       
  101.       /* Stack abuse */
  102.       BC_CASE(BC_SLIDE_STACK);
  103.       BC_CASE(BC_SLIDE_1);
  104.       BC_CASE(BC_SWAP);
  105.       BC_CASE(BC_DROP);
  106.       BC_CASE(BC_DROP_1);
  107.  
  108.       /* Leaping merrily */
  109.       BC_CASE(BC_BRANCH);
  110.       BC_CASE(BC_BRANCH_NIL);
  111.  
  112.       /* Calling things */
  113.       BC_CASE(BC_APPLY_ARGS);
  114.       BC_CASE(BC_APPLY_ANY);
  115.       BC_CASE(BC_APPLY_BVF);
  116.       BC_CASE(BC_APPLY_CFN);
  117.       BC_CASE(BC_APPLY_CFN2);
  118.       BC_CASE(BC_APPLY_METHODS);
  119.       BC_CASE(BC_APPLY_METHOD_LIST);
  120.  
  121.       BC_CASE(BC_PUSH_LABEL);
  122.       
  123.       /* and return */
  124.       BC_CASE(BC_RETURN);
  125.       /* real return */
  126.       BC_CASE(BC_EXIT);
  127.  
  128.       /* allocation */    
  129.       BC_CASE(BC_CONS);
  130.       BC_CASE(BC_ALLOC_CLOSURE);
  131.       BC_CASE(BC_ALLOC_EXT_CLOSURE);
  132.  
  133.       /* Tests */
  134.       BC_CASE(BC_NULLP);
  135.       BC_CASE(BC_EQP);
  136.       BC_CASE(BC_CONSP);
  137.       
  138.       BC_CASE(BC_CONTEXT); 
  139.       
  140.       /* Inlined functions */
  141.       BC_CASE(BC_ASSQ);
  142.       BC_CASE(BC_MEMQ);
  143.       BC_CASE(BC_SCANQ);
  144.       /* darn, no such bytecode...*/
  145.       BC_NOINSTRUCT(*(pc-1));
  146.     }
  147.       Cb_generic_lookup=BCnil;
  148.     }
  149.   /* not ever */
  150.   return nil; 
  151. }
  152.  
  153.  
  154. /* Returns a closure which will execute from 0 */
  155. /* It is vital that the vector is not GC'd */
  156. EUFUN_4(Fn_add_codevector,bytes,nbytes, statics, nstatics)
  157. {
  158.   LispObject new_closure;
  159.   LispObject ptr,codevector, slotvector;
  160.   int i,lim=intval(nbytes);
  161.   bytecode *space;
  162.  
  163.   codevector=allocate_static_string(stacktop,lim);
  164.   slotvector = allocate_static_vector(stacktop, intval(nstatics));
  165.   vref(static_vectors,SYSTEM_GLOBAL_VALUE(static_count))=slotvector;
  166.   
  167.   space=(bytecode *)stringof(codevector);
  168.  
  169.   ptr=bytes;
  170.  
  171.   for (i=0; i<lim ; i++)
  172.     {
  173.       if (!is_fixnum(CAR(ptr)))
  174.     CallError(stacktop,"add codevector: bad byte",CAR(ptr),NONCONTINUABLE);
  175.       
  176.       if (intval(CAR(ptr))>255)
  177.     CallError(stacktop,"add codevector: bad byte number",CAR(ptr),NONCONTINUABLE);
  178.  
  179.       space[i]=(bytecode)intval(CAR(ptr));
  180.       ptr=CDR(ptr);
  181.     }
  182.   
  183.   ptr=statics;
  184.   for (i=1 ; i<intval(nstatics) ; i++)
  185.     {
  186.       vref(slotvector,i)=CAR(ptr);
  187.       ptr=CDR(ptr);
  188.     }
  189.  
  190.   vref(slotvector,0)=codevector;
  191.   /* Allocate a new closure and interpret it. */
  192.   new_closure=allocate_instance(stacktop,ByteFunction);
  193.   lval_typeof(new_closure)=TYPE_B_FUNCTION;
  194.  
  195.   bytefunction_offset(new_closure)=allocate_integer(stacktop,0);
  196.   bytefunction_nargs(new_closure)=allocate_integer(stacktop,0);
  197.   bytefunction_env(new_closure)=nil;
  198.   bytefunction_globals(new_closure)=slotvector; /* XXX: GC proof */
  199.   SYSTEM_GLOBAL_VALUE(static_count)++;
  200.   
  201.   return(apply_nary_bytefunction(stacktop,0,new_closure));
  202. }
  203. EUFUN_CLOSE
  204.  
  205. #ifdef WITH_SPECIAL_METHODS
  206. /* Nary methods --- needed here 'cos the interpreter needs them */
  207. LispObject apply_special_method(LispObject *stackbase, int nargs, LispObject meth)
  208. {
  209.   LispObject *stacktop=stackbase+nargs-1;
  210.  
  211.   BC_METHOD_SWITCH(stacktop,intval(special_method_id(meth)));
  212.   
  213.   return (*stackbase);
  214. }
  215. #endif
  216.  
  217. #define BUFSIZE 1024
  218. EUFUN_1(Fn_load_bytecodes,name)
  219. {
  220.   char buf[BUFSIZE];
  221.   FILE *file;
  222.   bytecode *code;
  223.   int nslots,nbytes,i;
  224.   LispObject slotvector,*slots,codevector,stream;
  225.   
  226.   sprintf(buf,"%s.ebc",stringof(name));
  227.   file=fopen(buf,"r");
  228.  
  229.   if (file==NULL)
  230.     {    
  231.       fprintf(stderr,"cannot open file %s\n",buf);
  232.       system_lisp_exit(1);
  233.     }
  234.  
  235.   fgets(buf,BUFSIZE,file);
  236.   
  237.   if (strcmp(buf,"ASCIIBYTES\n")==0)
  238.     {
  239.       fgets(buf,BUFSIZE,file);
  240.       nslots=atoi(buf);
  241.       fgets(buf,BUFSIZE,file);
  242.       nbytes=atoi(buf);
  243.  
  244.       codevector= allocate_static_string(stacktop,nbytes);      
  245.       code=(bytecode *) stringof(codevector);
  246.       slotvector=allocate_static_vector(stacktop,nslots);
  247.       vref(static_vectors,SYSTEM_GLOBAL_VALUE(static_count))=slotvector;
  248.  
  249.       fprintf(stderr,"code: %d bytes, %d slots\n",nbytes,nslots);
  250.       STACK_TMP(slotvector);
  251.       
  252.       for (i=0 ; i<nbytes ; i++)
  253.     {    
  254.       if (fgets(buf,BUFSIZE,file)==NULL)
  255.         perror("fgets");
  256.  
  257.       code[i]=(bytecode) (atoi(buf));
  258.     }
  259.       fclose(file);
  260.     }
  261.   else
  262.     {    
  263.       fprintf(stderr,"%s\n",buf);
  264.       CallError(stacktop,"Unknown format: %s\n",nil,NONCONTINUABLE);
  265.     }
  266.   
  267.   /* Load the statics --- should be done in lisp but what the hell... */
  268.  
  269.   sprintf(buf,"%s.est",stringof(name));
  270.   file=fopen(buf,"r");
  271.   if (file==NULL)
  272.     {
  273.       fprintf(stderr,"cannot open file %s\n",buf);
  274.       system_lisp_exit(1);
  275.     }
  276.   else
  277.     {
  278.       LispObject new;
  279.  
  280.       new=sys_read(stacktop,file);
  281.       nslots=intval(new);
  282.       for (i=0; i<nslots ; i++)
  283.     {
  284.       new=sys_read(stacktop,file);
  285.       vref(vref(static_vectors,SYSTEM_GLOBAL_VALUE(static_count)),i)=new;
  286.     }
  287.       fclose(file);
  288.     }
  289.   vref(slotvector,0)=codevector;
  290.   /* Allocate a new closure and interpret it. */
  291.   {
  292.     LispObject apply_nary_bytefunction(LispObject *, int, LispObject);
  293.     LispObject new_closure;
  294.   
  295.   new_closure=allocate_instance(stacktop,ByteFunction);
  296.     lval_typeof(new_closure)=TYPE_B_FUNCTION;
  297.  
  298.     bytefunction_offset(new_closure)=allocate_integer(stacktop,0);
  299.     bytefunction_nargs(new_closure)=allocate_integer(stacktop,0);
  300.     bytefunction_env(new_closure)=nil;
  301.     bytefunction_globals(new_closure)=slotvector; /* XXX: GC proof */
  302.     SYSTEM_GLOBAL_VALUE(static_count)++;
  303.     GLOBAL_REF(BC_Debug)=lisptrue;
  304.     return(apply_nary_bytefunction(stacktop,0,new_closure));
  305.   }
  306. }
  307. EUFUN_CLOSE
  308.  
  309.  
  310. EUFUN_2(Fn_set_module_statics,module,vect)
  311. {
  312.   int i;
  313.   
  314.   module->C_MODULE.values=vect;
  315.  
  316.   return nil;
  317. }
  318. EUFUN_CLOSE
  319.  
  320. LispObject apply_nary_bytefunction(LispObject *stackbase, int nargs, LispObject fn)
  321. {
  322.   bytecode *start;
  323.   LispObject this_vector,this_context,this_code; /* to make reify do the business */
  324.   LispObject rfn,*fake_sp;
  325.   int i;
  326.   
  327.   if (is_cons(fn))
  328.     rfn=method_function(CAR(fn));
  329.   else 
  330.     rfn=fn;
  331.   /* move the arguments up a little --- top first */
  332.   
  333.   for (i=nargs-1; i>=0 ; i--)
  334.     *(stackbase+i+3)= *(stackbase+i);
  335.  
  336.   /* Place the exit function in the return address */    
  337.   fake_sp=stackbase-1;
  338.   start=(bytecode *)stringof(vref(return_context,0));
  339.   this_context=return_context;
  340.   STASH_PC(fake_sp,start);
  341.  
  342.   /* hack fn slot */
  343.   *(stackbase+2)=fn;
  344.  
  345.   /* Hack env slot */
  346.   *(stackbase+nargs+3)=bytefunction_env(rfn);
  347.   this_context=bytefunction_globals(rfn);
  348.   /* Work out where to start (also updates this_vector)*/
  349.   start=BF2PC(rfn);  
  350.   
  351.   return(interpret_bytes(stackbase+nargs+4,start,this_context));
  352. }
  353.  
  354. EUFUN_0(Fn_print_counts)
  355. {
  356.   PRINT_COUNTS;
  357.  
  358.   return nil;
  359. }
  360. EUFUN_CLOSE
  361.  
  362. void add_boot_module(LispObject mod)
  363. {
  364.   if (static_vectors==NULL)
  365.     {
  366.       static_vectors=allocate_static_vector(NULL,MAX_MODS); /* NULL is a hack */
  367.       add_root(&static_vectors);
  368.       boot_modules=allocate_static_vector(NULL,MAX_BOOT_MODULES);
  369.       add_root(&boot_modules);
  370.     }
  371.  
  372.   vref(static_vectors,boot_module_count)=mod->C_MODULE.values;
  373.   vref(boot_modules,boot_module_count)=mod;
  374.   boot_module_count++;
  375. }
  376.  
  377. EUFUN_0(Fn_boot_module_list)
  378. {
  379.   LispObject lst,end;
  380.   int i;
  381.   
  382.   lst=EUCALL_2(Fn_cons,nil,nil);
  383.   end=lst; /* not gc safe */
  384.   for (i=1; i<boot_module_count; i++)
  385.     { 
  386.       LispObject tmp;
  387.  
  388.       tmp=EUCALL_2(Fn_cons,vref(boot_modules,i),nil);
  389.       CDR(end)=tmp;
  390.       end=tmp;
  391.     }
  392.   return(lst);
  393. }
  394. EUFUN_CLOSE
  395.  
  396. static EUFUN_2(Fn_set_global,n,val)
  397. {
  398.   GLOBAL_REF(intval(n))=val;
  399.  
  400.   return val;
  401. }
  402. EUFUN_CLOSE
  403.  
  404. static EUFUN_0(Fn_get_codepos)
  405. {
  406.   return (allocate_integer(stacktop,SYSTEM_GLOBAL_VALUE(static_count)-1));
  407. }
  408. EUFUN_CLOSE
  409.  
  410.  
  411. #define BCI_ENTRIES 10
  412. #define FIRST_USER_CODE 32
  413. MODULE Module_bci;
  414. LispObject Module_bci_values[BCI_ENTRIES];
  415.  
  416. void initialise_bci(LispObject *stacktop)
  417. {
  418.   int i;
  419.   
  420.   fprintf(stderr,"Bytecodes compiled on: %s\n", MAKE_DATE);
  421.   
  422.   SYSTEM_INITIALISE_GLOBAL(int,static_count,FIRST_USER_CODE);
  423.   global_vector=allocate_vector(stacktop,N_GLOBALS);
  424.   add_root(&global_vector);
  425.  
  426.   ByteFunction_Class = (LispObject) allocate_class(stacktop,Standard_Class);  
  427.   set_class_size(stacktop,ByteFunction_Class,Object, N_SLOTS_IN_CLASS);
  428.   add_root(&ByteFunction_Class);
  429.  
  430.   ByteFunction = (LispObject) allocate_class(stacktop,Standard_Class);
  431.   ExtByteFunction = (LispObject) allocate_class(stacktop,Standard_Class);
  432.   set_class_size(stacktop,ByteFunction,Object, N_SLOTS_IN_BYTEFUNCTION);
  433.   set_class_size(stacktop,ExtByteFunction,Object,N_SLOTS_IN_BYTEFUNCTION+1);
  434.   add_root(&ByteFunction);
  435.   add_root(&ExtByteFunction);
  436.  
  437.  
  438.   open_module(stacktop,
  439.           &Module_bci,Module_bci_values,"bci",BCI_ENTRIES);
  440.   
  441.   (void) make_module_entry(stacktop,"<bytefunction-class>",ByteFunction_Class);
  442.   (void) make_module_entry(stacktop,"<bytefunction>",ByteFunction);
  443.   (void) make_module_entry(stacktop,"<extended-bytefunction>",ExtByteFunction);
  444.   (void) make_module_function(stacktop,"add-code-vector",Fn_add_codevector,4);
  445.   (void) make_module_function(stacktop,"load-bytecodes",Fn_load_bytecodes,1);
  446.   (void) make_module_function(stacktop,"set-module-statics",Fn_set_module_statics,2);
  447.   (void) make_module_function(stacktop,"boot-module-list",Fn_boot_module_list,0);
  448.   (void) make_module_function(stacktop,"byte-counts",Fn_print_counts,0);
  449.   (void) make_module_function(stacktop,"get-bci-codepos",Fn_get_codepos,0);
  450.   (void) make_module_function(stacktop,"set-bc-global",Fn_set_global,2);
  451.   close_module();
  452.   
  453.   
  454.   {
  455.     LispObject tmp=allocate_static_string(stacktop,4);
  456.     stringof(tmp)[0]=(char)BC_EXIT;
  457.     return_context=allocate_static_vector(stacktop,1);
  458.     vref(return_context,0)=tmp;
  459.     
  460.     add_root(&return_context);
  461.   }
  462. }
  463.  
  464. /* Debugger helper functions... */
  465.  
  466. int debug_off()
  467. {
  468.   GLOBAL_REF(BC_Debug)=nil;
  469.   return 0;
  470. }
  471.  
  472. int debug_on()
  473. {
  474.   GLOBAL_REF(BC_Debug)=lisptrue;
  475.   return 1;
  476. }
  477.  
  478. #endif /* BCI */
  479.  
  480.  
  481.